home *** CD-ROM | disk | FTP | other *** search
/ Atari Mega Archive 1 / Atari Mega Archive - Volume 1.iso / language / pcl_src.zoo / init.lsp < prev    next >
Lisp/Scheme  |  1992-07-09  |  14KB  |  325 lines
  1. ;;;-*-Mode:LISP; Package:(PCL LISP 1000); Base:10; Syntax:Common-lisp -*-
  2. ;;;
  3. ;;; *************************************************************************
  4. ;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
  5. ;;; All rights reserved.
  6. ;;;
  7. ;;; Use and copying of this software and preparation of derivative works
  8. ;;; based upon this software are permitted.  Any distribution of this
  9. ;;; software or derivative works must comply with all applicable United
  10. ;;; States export control laws.
  11. ;;; 
  12. ;;; This software is made available AS IS, and Xerox Corporation makes no
  13. ;;; warranty about the software, its performance or its conformity to any
  14. ;;; specification.
  15. ;;; 
  16. ;;; Any person obtaining a copy of this software is requested to send their
  17. ;;; name and post office or electronic mail address to:
  18. ;;;   CommonLoops Coordinator
  19. ;;;   Xerox PARC
  20. ;;;   3333 Coyote Hill Rd.
  21. ;;;   Palo Alto, CA 94304
  22. ;;; (or send Arpanet mail to CommonLoops-Coordinator.pa@Xerox.arpa)
  23. ;;;
  24. ;;; Suggestions, comments and requests for improvements are also welcome.
  25. ;;; *************************************************************************
  26. ;;;
  27. ;;;
  28. ;;; This file defines the initialization and related protocols.
  29. ;;; 
  30.  
  31. (in-package 'pcl)
  32.  
  33. (declaim (type boolean *check-initargs-p*))
  34. (defvar *check-initargs-p* nil)
  35.  
  36. (defmacro checking-initargs (&body forms)
  37.   `(when *check-initargs-p* ,@forms))
  38.  
  39. (declaim (type boolean *making-instance-p*))
  40. (defvar *making-instance-p* nil)
  41.  
  42. (defmethod make-instance ((class slot-class) &rest initargs)
  43.   (declare (list initargs))
  44.   (unless (class-finalized-p class) (finalize-inheritance class))
  45.   (let ((class-default-initargs (class-default-initargs class)))
  46.     (when class-default-initargs
  47.       (setf initargs (default-initargs class initargs class-default-initargs)))
  48.     (when initargs
  49.       (when (and (eq *boot-state* 'complete)
  50.              (not (getf initargs :allow-other-keys)))
  51.         (let ((class-proto (class-prototype class)))
  52.           (check-initargs-1
  53.           class initargs
  54.         (append (compute-applicable-methods
  55.               #'allocate-instance (list* class initargs))
  56.             (compute-applicable-methods 
  57.               #'initialize-instance (list* class-proto initargs))
  58.             (compute-applicable-methods 
  59.               #'shared-initialize (list* class-proto t initargs)))))))
  60.     (let* ((*making-instance-p* T)
  61.            (instance (apply #'allocate-instance class initargs)))
  62.       (apply #'initialize-instance instance initargs)
  63.       instance)))
  64.  
  65. (defmethod make-instance ((class-name symbol) &rest initargs)
  66.   (apply #'make-instance (find-class class-name) initargs))
  67.  
  68. (defvar *default-initargs-flag* (list nil))
  69.  
  70. (defmethod default-initargs ((class slot-class) supplied-initargs all-default)
  71.   ;; This implementation of default initargs is critically dependent
  72.   ;; on all-default-initargs not having any duplicate initargs in it.
  73.   (let ((miss *default-initargs-flag*))
  74.     (flet ((getf* (plist key)
  75.          (do ()
  76.          ((null plist) miss)
  77.            (if (eq (car plist) key)
  78.            (return (cadr plist))
  79.            (setq plist (cddr plist))))))
  80.       (labels ((default-1 (tail)
  81.          (if (null tail)
  82.              nil
  83.              (if (eq (getf* supplied-initargs (caar tail)) miss)
  84.              (list* (caar tail)
  85.                 (funcall-function (cadar tail))
  86.                 (default-1 (cdr tail)))
  87.              (default-1 (cdr tail))))))
  88.     (append supplied-initargs (default-1 all-default))))))
  89.  
  90.  
  91. (defmethod allocate-instance ((class standard-class) &rest initargs)
  92.   (declare (ignore initargs))
  93.   (unless (or *making-instance-p* (class-finalized-p class))
  94.     (finalize-inheritance class))
  95.   (let* ((class-wrapper (class-wrapper class))
  96.          (instance (%allocate-instance--class
  97.                      (wrapper-allocate-static-slot-storage-copy
  98.                        class-wrapper))))
  99.     (setf (std-instance-wrapper instance) class-wrapper)
  100.     instance))
  101.  
  102. (defmethod allocate-instance ((class structure-class) &rest initargs)
  103.   (declare (ignore initargs))
  104.   (let ((constructor (class-defstruct-constructor class)))
  105.     (if constructor
  106.         (funcall-function (symbol-function constructor))
  107.         (error "Can't allocate an instance of class ~S" (class-name class)))))
  108.  
  109. (defmethod initialize-instance ((instance slot-object) &rest initargs)
  110.   (apply #'shared-initialize instance t initargs))
  111.  
  112.  
  113. (defmethod reinitialize-instance ((instance slot-object) &rest initargs)
  114.   (checking-initargs
  115.     (when (and initargs (eq *boot-state* 'complete)
  116.            (not (getf initargs :allow-other-keys)))
  117.       (check-initargs-1
  118.        (class-of instance) initargs
  119.        (append (compute-applicable-methods 
  120.         #'reinitialize-instance (list* instance initargs))
  121.            (compute-applicable-methods 
  122.         #'shared-initialize (list* instance nil initargs))))))
  123.   (apply #'shared-initialize instance nil initargs)
  124.   instance)
  125.  
  126.  
  127. (defmethod update-instance-for-different-class ((previous standard-object)
  128.                         (current standard-object)
  129.                         &rest initargs)
  130.   ;; First we must compute the newly added slots.  The spec defines
  131.   ;; newly added slots as "those local slots for which no slot of
  132.   ;; the same name exists in the previous class."
  133.   (let ((added-slots '())
  134.     (current-slotds (class-slots (class-of current)))
  135.     (previous-slot-names (mapcar #'slot-definition-name
  136.                      (class-slots (class-of previous)))))
  137.     (dolist (slotd current-slotds)
  138.       (if (and (not (memq (slot-definition-name slotd) previous-slot-names))
  139.            (eq (slot-definition-allocation slotd) ':instance))
  140.       (push (slot-definition-name slotd) added-slots)))
  141.     (checking-initargs
  142.       (when (and initargs (not (getf initargs :allow-other-keys)))
  143.     (check-initargs-1
  144.      (class-of current) initargs
  145.      (append (compute-applicable-methods 
  146.           #'update-instance-for-different-class 
  147.           (list* previous current initargs))
  148.          (compute-applicable-methods 
  149.           #'shared-initialize (list* current added-slots initargs))))))
  150.     (apply #'shared-initialize current added-slots initargs)))
  151.  
  152. (defmethod update-instance-for-redefined-class ((instance standard-object)
  153.                         added-slots
  154.                         discarded-slots
  155.                         property-list
  156.                         &rest initargs)
  157.   (checking-initargs
  158.     (when (and initargs (not (getf initargs :allow-other-keys)))
  159.       (check-initargs-1
  160.        (class-of instance) initargs
  161.        (append (compute-applicable-methods 
  162.         #'update-instance-for-redefined-class 
  163.         (list* instance added-slots discarded-slots property-list initargs))
  164.            (compute-applicable-methods 
  165.         #'shared-initialize (list instance added-slots initargs))))))
  166.   (apply #'shared-initialize instance added-slots initargs))
  167.  
  168. (defmethod shared-initialize
  169.        ((instance slot-object) slot-names &rest initargs)
  170.   (declare (list initargs))
  171.   (declare #.*optimize-speed*)
  172.   ;;
  173.   ;; initialize the instance's slots in a two step process
  174.   ;;   1. A slot for which one of the initargs in initargs can set
  175.   ;;      the slot, should be set by that initarg.  If more than
  176.   ;;      one initarg in initargs can set the slot, the leftmost
  177.   ;;      one should set it.
  178.   ;;
  179.   ;;   2. Any slot not set by step 1, may be set from its initform
  180.   ;;      by step 2.  Only those slots specified by the slot-names
  181.   ;;      argument are set.  If slot-names is:
  182.   ;;       T
  183.   ;;            any slot not set in step 1 is set from its
  184.   ;;            initform
  185.   ;;       <list of slot names>
  186.   ;;            any slot in the list, and not set in step 1
  187.   ;;            is set from its initform
  188.   ;;
  189.   ;;       ()
  190.   ;;            no slots are set from initforms
  191.   ;;
  192.   (flet
  193.    ((init-safe (slots initing-internal-slotds)
  194.       (dolist (internal-slotd initing-internal-slotds)
  195.        (unless
  196.          (and
  197.            initargs
  198.            ;; Try to initialize the slot from one of the initargs.
  199.            (let ((slot-initargs (internal-slotd-initargs internal-slotd))
  200.                  (initargs-ptr  initargs))
  201.              (loop
  202.                (when (memq (car initargs-ptr) slot-initargs)
  203.                  (let ((location (internal-slotd-location internal-slotd)))
  204.                    (typec